home *** CD-ROM | disk | FTP | other *** search
/ CD Fun House 8 / CD Funhouse Version 8.0 - Wayzata Technology (7013) (1993).iso / pc / pc / boards / tarot / tarot.pas < prev   
Pascal/Delphi Source File  |  1990-01-04  |  11KB  |  332 lines
  1. {$A+,B-,D+,E-,F-,I-,L+,N-,O-,R-,S-,V+}
  2. {$M 16384,0,0}
  3. PROGRAM TAROT;
  4.  
  5. USES DOS,CRT,PRINTER;
  6.  
  7. TYPE
  8.     DECK_TYPE = ARRAY [0..21] OF BYTE;
  9.     CUT_TYPE  = ARRAY [1..4]  OF BYTE;
  10.     CARD_TYPE = RECORD
  11.                  NAME       :STRING[14];
  12.                  ROMAN      :STRING[5];
  13.                  MEANING    :STRING[75];
  14.                 END;
  15.  
  16. CONST
  17.   EFFECTON=#27#71;               {printer effect on "card" - doublestrike}
  18.   EFFECTOFF=#27#72;
  19.   CARD:ARRAY [0..21] OF CARD_TYPE=(
  20.  (NAME:'   The Fool   ';ROMAN:'  0  ';MEANING:   {0}
  21.  'Foolishness, Frenzy, Impulsiveness, Heedlessness, Agitation, Blunder       '),
  22.  (NAME:' The Magician ';ROMAN:'  I  ';MEANING:   {1}
  23.  'Skill, Artistry, Assurance, Determination, Versatility, Competence         '),
  24.  (NAME:'High Priestess';ROMAN:' II  ';MEANING:   {2}
  25.  'Knowledge, Intelligence, Understanding, Scholarship, Wisdom                '),
  26.  (NAME:' The Empress  ';ROMAN:' III ';MEANING:   {3}
  27.  'Activity, Growth, Fertility, Productiveness, Progress                      '),
  28.  (NAME:' The Emperor  ';ROMAN:' IV  ';MEANING:   {4}
  29.  'Nobility, Power, Achievement, Supremacy, Wealth, Dominance                 '),
  30.  (NAME:'The Hierophant';ROMAN:'  V  ';MEANING:   {5}
  31.  'Gentleness, Sacredness, Benevolence, Leniency, Righteousness, Tenderness   '),
  32.  (NAME:'  The Lovers  ';ROMAN:' VI  ';MEANING:   {6}
  33.  'Attraction, Loveliness, Affection, Elegance, Concord                       '),
  34.  (NAME:' The Chariot  ';ROMAN:' VII ';MEANING:   {7}
  35.  'Domination, Triumph, Discord, Victory, Trouble, Challenge                  '),
  36.  (NAME:'  Strength    ';ROMAN:'VIII ';MEANING:   {8}
  37.  'Fortitude, Firmness, Confidence, Assurance                                 '),
  38.  (NAME:'  The Hermit  ';ROMAN:' IX  ';MEANING:   {9}
  39.  'Discretion, Tact, Judiciousness, Heed, Circumspection, Preparedness        '),
  40.  (NAME:'Wheel  Fortune';ROMAN:'  X  ';MEANING:   {10}
  41.  'Providence, Predestination, Authority, Honor, Principle                    '),
  42.  (NAME:'   Justice    ';ROMAN:' XI  ';MEANING:   {11}
  43.  'Morality, Virtue, Fairness, Rectitude                                      '),
  44.  (NAME:'The Hanged Man';ROMAN:' XII ';MEANING:   {12}
  45.  'Sacrifice, Transcendance, Glory, Renunciation, Piety, Stability            '),
  46.  (NAME:'    Death     ';ROMAN:'XIII ';MEANING:   {13}
  47.  'Great Change, Destination, Rebirth, Creation, Renewal                      '),
  48.  (NAME:'  Temperance  ';ROMAN:' XIV ';MEANING:   {14}
  49.  'Harmony, Moderation, Rationality, Friendliness, Forbearance                '),
  50.  (NAME:'  The Devil   ';ROMAN:' XV  ';MEANING:   {15}
  51.  'Evil, Catastrophe, Captivity, Disorder, Violence                           '),
  52.  (NAME:'  The Tower   ';ROMAN:' XVI ';MEANING:   {16}
  53.  'Ruin, Suffering, Affliction, Chastisement, Unexpectedness, Disaster        '),
  54.  (NAME:'  The Star    ';ROMAN:'XVII ';MEANING:   {17}
  55.  'Truth, Promise, Propitiousness, Fulfillment, Beauty, Immortality           '),
  56.  (NAME:'  The Moon    ';ROMAN:'XVIII';MEANING:   {18}
  57.  'Savagery, Peril, Instability, Falsehood, Disillusionment                   '),
  58.  (NAME:'   The Sun    ';ROMAN:' XIX ';MEANING:   {19}
  59.  'Sensitivity, Innocence, Pleasure, Renewal, Restoration, Victory, Perfection'),
  60.  (NAME:'  Judgement   ';ROMAN:' XX  ';MEANING:   {20}
  61.  'Discovery, Development, Resolution, Conclusion                             '),
  62.  (NAME:'  The World   ';ROMAN:' XXI ';MEANING:   {21}
  63.  'Culmination, Triumph, Self-Awareness, Natural Perfection                   '));
  64.   QUESTION:ARRAY [0..9] OF STRING[75]=(
  65.  'The influence affecting the questioner; the atmosphere around the question ',
  66.  'The obstacles facing the questioner                                        ',
  67.  'The most practical goal that the questioner can achieve or avoid           ',
  68.  'The Present                                                                ',
  69.  'The Past                                                                   ',
  70.  'The Future                                                                 ',
  71.  'The questioner''s frame of mind                                             ',
  72.  'The questioner''s enviroment, position in life, what his/her friends think  ',
  73.  'The questioner''s fears, hopes, or predictions                              ',
  74.  'The final outcome, what this will end up as                                ');
  75.  
  76.   VAR
  77.    DECK     :DECK_TYPE;
  78.    TIMES,
  79.    W        :WORD;
  80.    I        :BYTE;
  81.    CH       :CHAR;
  82.    CUTPOINT :CUT_TYPE;
  83.  
  84. {-------------------------------------------------------------}
  85. PROCEDURE WAIT;
  86.  
  87. VAR
  88.   X,Y       :BYTE;
  89.  
  90. BEGIN
  91.    X:=WHEREX; Y:=WHEREY;
  92.    GOTOXY (1,25);
  93.    WRITE ('Press any key to continue....');
  94.    CH:=READKEY;
  95.    GOTOXY (X,Y);
  96. END;
  97. {-------------------------------------------------------------}
  98. PROCEDURE SHUFFLE (TIMES   :WORD);
  99.  
  100. VAR
  101.   T          :WORD;
  102.   B,
  103.   NUM1,
  104.   NUM2       :BYTE;
  105.  
  106.  
  107. BEGIN
  108.    RANDOMIZE;
  109.    FOR I:=0 TO 21 DO
  110.      DECK[I]:=I;
  111.    FOR T:=1 TO TIMES DO
  112.     BEGIN
  113.       IF T MOD 100=0
  114.         THEN
  115.          BEGIN
  116.            GOTOXY (1,WHEREY); CLREOL;
  117.            WRITE ('Shuffling...',T);
  118.          END;
  119.      FOR I:=1 TO 10 DO
  120.       BEGIN
  121.        NUM1:=RANDOM(22);
  122.        NUM2:=RANDOM(22);
  123.        B:=DECK[NUM1];
  124.        DECK[NUM1]:=DECK[NUM2];
  125.        DECK[NUM2]:=B;
  126.       END;
  127.     END;
  128. END;
  129. {-------------------------------------------------------------}
  130. PROCEDURE CUT;
  131.  
  132. VAR
  133.   TEMPDECK   :DECK_TYPE;
  134.   J,
  135.   B          :BYTE;
  136.   LOOP       :BOOLEAN;
  137.  
  138. BEGIN
  139.   LOOP:=TRUE;
  140.   REPEAT
  141.     IF CUTPOINT[1]<CUTPOINT[2]
  142.        THEN BEGIN IF CUTPOINT[2]<CUTPOINT[3]
  143.             THEN BEGIN LOOP:=FALSE END
  144.             ELSE
  145.               BEGIN
  146.                 B:=CUTPOINT[2];
  147.                 CUTPOINT[2]:=CUTPOINT[3];
  148.                 CUTPOINT[3]:=B;
  149.               END;
  150.            END
  151.        ELSE
  152.          BEGIN
  153.            B:=CUTPOINT[1];
  154.            CUTPOINT[1]:=CUTPOINT[2];
  155.            CUTPOINT[2]:=B;
  156.          END;
  157.   UNTIL LOOP=FALSE;
  158.   IF CUTPOINT[4]>14
  159.      THEN
  160.        BEGIN
  161.          I:=0;
  162.          FOR B:=CUTPOINT[3] TO 21 DO
  163.            BEGIN TEMPDECK[I]:=DECK[B]; I:=I+1; END;
  164.          FOR B:=0 TO CUTPOINT[3]-1 DO
  165.            BEGIN TEMPDECK[I]:=DECK[B]; I:=I+1; END;
  166.          DECK:=TEMPDECK;
  167.        END
  168.     ELSE
  169.      IF CUTPOINT[4]>7
  170.         THEN
  171.           BEGIN
  172.             I:=0;
  173.             J:=RANDOM(2)+1;
  174.             FOR B:=CUTPOINT[J] TO 21 DO
  175.               BEGIN TEMPDECK[I]:=DECK[B]; I:=I+1; END;
  176.             FOR B:=0 TO CUTPOINT[J]-1 DO
  177.               BEGIN TEMPDECK[I]:=DECK[B]; I:=I+1; END;
  178.             DECK:=TEMPDECK;
  179.           END;
  180. END;
  181. {-------------------------------------------------------------}
  182. PROCEDURE SETUP;
  183.  
  184. VAR
  185.   A,B,C,X,Y      :BYTE;
  186.  
  187. BEGIN
  188.    FOR Y:=0 TO 1 DO
  189.      FOR X:=0 TO 4 DO
  190.        BEGIN
  191.          IF X=4
  192.             THEN WINDOW (X*16+1,Y*10+1,80,25)
  193.             ELSE WINDOW (X*16+1,Y*10+1,X*16+16,Y*10+11);
  194.          WRITE   ('⁄ƒƒƒƒƒƒƒƒƒƒƒƒƒƒø');
  195.          FOR A:=1 TO 8 DO
  196.           BEGIN
  197.            IF A MOD 2=0
  198.               THEN WRITE ('≥±≤±≤±≤±≤±≤±≤±≤≥')
  199.               ELSE WRITE ('≥≤±≤±≤±≤±≤±≤±≤±≥');
  200.           END;
  201.          WRITE   ('¿ƒƒƒƒƒƒƒƒƒƒƒƒƒƒŸ');
  202.        END;
  203.   WINDOW (1,1,80,25);
  204. END;
  205. {-------------------------------------------------------------}
  206. PROCEDURE SHOW;
  207.  
  208. VAR
  209.   X,Y    :BYTE;
  210.  
  211. BEGIN
  212.    CLRSCR;
  213.    SETUP;
  214.    WAIT;
  215.    I:=0;
  216.    FOR Y:=0 TO 1 DO
  217.      FOR X:= 0 TO 4 DO
  218.        BEGIN
  219.          WINDOW (X*16+2,Y*10+2,X*16+15,Y*10+9);
  220.          CLRSCR;
  221.          GOTOXY (5,2);
  222.          WRITE (CARD[DECK[I]].ROMAN);
  223.          GOTOXY (1,7); HIGHVIDEO;
  224.          IF DECK[I]=10
  225.             THEN
  226.               BEGIN
  227.                 GOTOXY (3,6); WRITE ('Wheel  of');
  228.                 GOTOXY (4,7); WRITE ('Fortune');
  229.               END
  230.             ELSE WRITE (CARD[DECK[I]].NAME);
  231.          LOWVIDEO;
  232.          WINDOW (1,1,80,25);
  233.          GOTOXY (1,21);
  234.          WRITELN ('This position concerns: '); HIGHVIDEO;
  235.          WRITELN ('  ',QUESTION[I]); LOWVIDEO;
  236.          WRITELN ('This card means: '); HIGHVIDEO;
  237.          WRITELN ('  ',CARD[DECK[I]].MEANING); LOWVIDEO;
  238.          IF I<9
  239.             THEN WAIT;
  240.          I:=I+1;
  241.        END;
  242. END;
  243. {------------------------------------------------------------}
  244. PROCEDURE PRINT;
  245.  
  246. VAR
  247.   REGS         :REGISTERS;
  248.   VIDMEMST     :WORD;
  249.  
  250. BEGIN
  251.    INTR($11,REGS);
  252.    IF LO(REGS.AX) AND $30 = $30
  253.       THEN VIDMEMST:=$B000
  254.       ELSE VIDMEMST:=$B800;
  255.    FOR W:=0 TO 3199 DO
  256.     IF W MOD 2=0
  257.        THEN WRITE (LST,CHR(MEM[VIDMEMST:W]));
  258.    WRITELN (LST);
  259.    FOR I:=0 TO 9 DO
  260.      BEGIN
  261.        WRITELN (LST,EFFECTON,
  262.                  'Card ',CARD[DECK[I]].ROMAN,'- ',CARD[DECK[I]].NAME,
  263.                   EFFECTOFF);
  264.        WRITELN (LST,' ',QUESTION[I]);
  265.        WRITELN (LST,'  ',CARD[DECK[I]].MEANING);
  266.      END;
  267.    WRITELN (LST,^L);
  268. END;
  269. {============================================================}
  270.  
  271. BEGIN
  272.   REPEAT
  273.    CLRSCR; LOWVIDEO;
  274.    GOTOXY (27,2); WRITELN ('TAROT READER - MAJOR ARCANA');
  275.    WRITELN;
  276.    WRITELN ('Ask the computer what you would like it to talk about before');
  277.    WRITELN ('doing anything else!');
  278.    WRITELN;
  279.    WRITE ('Enter number of times to shuffle deck: ');
  280.    READLN (TIMES);
  281.    WRITELN;
  282.    WRITELN ('Now enter 4 numbers between 1 and 500 so I can cut the deck.');
  283.    FOR I:=1 TO 4 DO
  284.      BEGIN
  285.        REPEAT
  286.          WRITE (' Enter number ',I,': ');
  287.          READLN (W);
  288.          IF (W<1) OR (W>500)
  289.             THEN
  290.               BEGIN
  291.                 GOTOXY (30,WHEREY-1);
  292.                 WRITELN ('<--  Not between 1 and 500!',^G);
  293.               END
  294.             ELSE
  295.              BEGIN
  296.                CUTPOINT[I]:=TRUNC(W/22.72727273) - 1;
  297.                IF (CUTPOINT[I]>21) OR (CUTPOINT[I]<1)
  298.                   THEN CUTPOINT[I]:=1;
  299.                IF (I>1) AND (I<4)
  300.                   THEN IF (CUTPOINT[I]=CUTPOINT[I-1]) OR ((I=3) AND
  301.                           (CUTPOINT[3]=CUTPOINT[1]))
  302.                           THEN
  303.                            BEGIN
  304.                             GOTOXY (30,WHEREY-1);
  305.                             WRITELN ('<--  I don''t like that number, try again.',^G);
  306.                             W:=1000;
  307.                            END;
  308.              END;
  309.        UNTIL (W>0) AND (W<501);
  310.      END;
  311.    WRITELN; WRITE ('Shuffling...');
  312.    SHUFFLE (TIMES);
  313.    CUT;
  314.    WRITELN; WRITELN; WRITELN ('Your deck is shuffled, cut and ready to go!');
  315.    WAIT;
  316.    SHOW;
  317.    GOTOXY (1,25); CLREOL;
  318.    CH:='X';
  319.    WHILE NOT (CH IN ['Q','A']) DO
  320.     BEGIN
  321.       GOTOXY (1,25); CLREOL;
  322.       WRITE ('A)gain, P)rint, Q)uit (A/P/Q)? ');
  323.       CH:=UPCASE(READKEY);
  324.       IF CH='P'
  325.          THEN PRINT
  326.          ELSE IF NOT (CH IN ['Q','A'])
  327.                  THEN WRITE (^G);
  328.     END;
  329.   UNTIL CH='Q';
  330.   NORMVIDEO;
  331.   CLRSCR;
  332. END.